perm filename BITLAB[PAT,LMM] blob
sn#097623 filedate 1974-04-15 generic text, type T, neo UTF8
(FILECREATED "15-APR-74 07:16:54" BITLABELER)
(LISPXPRINT (QUOTE BITLABELERVARS)
T)
[RPAQQ BITLABELERVARS
((COMPROP MACRO 2TO LOG2 CONTAINED ELTLESSP TWICE NEXTSMALLESTELT
DISJOINTDIFF ALLLARGERELTS LARGESTELT MAKESET DIFF1
ELEMENTOF ADDELT SETDIFF EMPTY UNIONSET INTERSECT DISJOINT
NULLSET EQSET SETSIZE FIRST REST)
(FNS LLABELNODES BITLABEL BITGROUP FIXBITGROUP LISTCYCLES ELTTIMES
PERMTIMES TAKEN GCD RELATIVELYPRIME LCM PERMCYCLEINDEX1
BINARY.LSTG LST.BINARYG BINARY.LST LST.BINARY LOG2 CONTAINED
LISTELT DM SETDIFF SETSIZE FIRST REST LABELGRAPH INSERTCL DIFFCL
SUBSETS PCYCLEINDEX CYCLEINDEX LFROMCL POLYA INSERT
SLTPSANDPINVS)
(FNS MLG ORBIT1 REDUCEGROUP ALLSUBSETS MANYLABELGRAPHTOP
MANYLABELGRAPH LABELCLASS LABELGENCLASS LABELORBITS LO1 LOADD
ORBITS CANONICAL SLTPS)
(VARS (INPUTMODE (QUOTE FUNCTION]
(DEFLIST(QUOTE(
[2TO ((N)
(LLSH 1 (SUB1 N]
(LOG2 NIL)
[CONTAINED ((A B)
(ZEROP (LOC (ASSEMBLE NIL (CQ (VAG A))
(PUSHN)
(CQ (VAG B))
(POP NP , 10)
(XOR 1 , 10)
(AND 1 , 10]
(ELTLESSP ((X Y)
(IGREATERP X Y)))
(TWICE ((X)
(LLSH X 1)))
(NEXTSMALLESTELT ((X)
(TWICE X)))
(DISJOINTDIFF ((X Y)
(LOGXOR X Y)))
(ALLLARGERELTS ((X)
(SUB1 X)))
(LARGESTELT (NIL 1))
(MAKESET (X (CONS (QUOTE LOGOR)
X)))
(DIFF1 ((A B)
(SETDIFF A B)))
(ELEMENTOF ((X A)
(CONTAINED X A)))
(ADDELT ((X A)
(UNION X A)))
[SETDIFF ((A B)
(LOC (ASSEMBLE NIL (CQ (VAG A))
(PUSHN)
(CQ (VAG B))
(POP NP , 2)
(XOR 1 , 2)
(AND 1 , 2]
(EMPTY ((X)
(ZEROP X)))
(UNIONSET ((A B)
(LOGOR A B)))
(INTERSECT ((A B)
(LOGAND A B)))
[DISJOINT ((A B)
(EMPTY (INTERSECT A B]
(NULLSET (NIL 0))
(EQSET ((X Y)
(EQP X Y)))
[SETSIZE ((A)
(LOC (ASSEMBLE NIL (CQ (VAG A))
(MOVE 2 , 1)
(HRRZI 1 , 0)
(JUMPE 2 , RET)
LP
(ADDI 1 , 1)
(MOVE 3 , 2)
(SUBI 3 , 1)
(AND 2 , 3)
(JUMPN 2 , LP)
RET]
[FIRST ((X)
(LOC (ASSEMBLE NIL (CQ (VAG X))
(HRREI 2 , -1)
(ADD 2 , 1)
(XOR 2 , 1)
(AND 1 , 2]
[REST ((X)
(LOC (ASSEMBLE NIL (CQ (VAG X))
(HRREI 2 , -1)
(ADD 2 , 1)
(AND 1 , 2]
))(QUOTE MACRO)(QUOTE EVALUATE©))
(DEFINEQ
(LLABELNODES
[LAMBDA (STRUC LLABELS)
(PROG ((NEWNODES (LISTBYVALENCE STRUC)))
(COND
([for X in LLABELS as Y in NEWNODES
always (for ZZ in X always (OR (ZEROP ZZ)
(EQLENGTH Y ZZ]
(* FOR EACH TYPE OF VALENCE,
THERE IS ONLY ONE LABEL TYPE)
(LIST (create LABELING LABELED ←[for X in LLABELS as Y
in NEWNODES
collect
(for ZZ in X
collect
(COND
((NOT (ZEROP ZZ))
Y]
LSTRUC ← STRUC)))
(T (for L in (BITLABEL (for X in NEWNODES
collect (OR (LST.BINARY X)
0))
LLABELS
(BITGROUP STRUC))
collect (create LABELING reusing L LABELED ←(BINARY.LST
(fetch LABELED
of L))
LSTRUC ←(FIXBITGROUP
STRUC
(fetch LSTRUC
of L])
(BITLABEL
[LAMBDA (NODESLIST LABELSLIST GROUP)
(COND
((OR (NULL LABELSLIST)
(NULL NODESLIST))
(AND LABELSLIST (NOT (EVERY NODESLIST (QUOTE ZEROP)))
(HELP "INCONSISTANT CONDITION IN BITLABEL"))
(LIST (create LABELING LSTRUC ← GROUP)))
(T (for L1 in (MANYLABELGRAPH (CAR NODESLIST)
(CAR LABELSLIST)
GROUP)
join (for L2 in (BITLABEL (CDR NODESLIST)
(CDR LABELSLIST)
(fetch LSTRUC of L1))
rcollect (create LABELING
reusing L2 LABELED ←(CONS (fetch LABELED
of L1)
(fetch LABELED
of L2])
(BITGROUP
[LAMBDA (STRUC)
[COND
([EVERY
(fetch GROUP of STRUC)
(FUNCTION (LAMBDA (X Y)
(AND
(OR (NULL (CDR Y))
(LISTP (CDR Y)))
(EVERY X
(FUNCTION (LAMBDA (X1 Y1)
(AND (OR (NULL (CDR Y1))
(LISTP (CDR Y1)))
(EVERY X1
(FUNCTION (LAMBDA (Z ZT)
(AND (OR (NULL (CDR ZT))
(LISTP (CDR ZT)))
(NUMBERP Z]
(FIXUPGROUP STRUC)
(replace GROUP
of STRUC
with (CONS (fetch LASTNODE# of STRUC)
(LST.BINARYG (MAPCAR (fetch GROUP of STRUC)
(FUNCTION (LAMBDA (PERM)
(MAPCONC
PERM
(FUNCTION (LAMBDA (X)
(APPEND X]
(COND
((NEQ (CAR (fetch GROUP of STRUC))
(fetch LASTNODE# of STRUC))
(HELP "NEED TO FIXUPBITGROUP ")))
(CDR (fetch GROUP of STRUC])
(FIXBITGROUP
[LAMBDA (STRUC GROUP)
(replace GROUP of STRUC with (CONS (fetch LASTNODE# of STRUC)
GROUP])
(LISTCYCLES
[LAMBDA (PERM)
(* Returns the list of cycles of perm, where a cycle is a
list of elements)
(PROG (LS X PX)
(SETQ X (CAR PERM))
(SETQ PX X)
L1 (SETQ LS (CONS [PROG ((RSLT))
LP (SETQ PX (ELTTIMES PX PERM))
(SETQ RSLT (CONS PX RSLT))
(COND
((EQ PX X)
(RETURN RSLT))
(T (GO LP]
LS))
[COND
((for old X in PERM always (thereis CYCLE in LS
suchthat (MEMB X CYCLE)))
(RETURN (for X in LS when (CDR X) collect X]
(SETQ PX X)
(GO L1])
(ELTTIMES
[LAMBDA (X P)
(CAR (FNTH P X])
(PERMTIMES
[LAMBDA (P1 P2)
(for X in P1 collect (ELTTIMES X P2])
(TAKEN
[LAMBDA (N I)
(bind RESULT←1 for J from 1 to I do (SETQ RESULT (IQUOTIENT (ITIMES RESULT
N)
J))
(SETQ N (SUB1 N))
finally (RETURN RESULT])
(GCD
[LAMBDA (N1 N2)
(COND
((EQ 0 (SETQ N1 (IREMAINDER N1 N2)))
N2)
(T (GCD N2 N1])
(RELATIVELYPRIME
[LAMBDA (N1 N2)
(EQ 1 (GCD N1 N2])
(LCM
[LAMBDA (N1 N2)
(IQUOTIENT (ITIMES N1 N2)
(GCD N1 N2])
(PERMCYCLEINDEX1
[LAMBDA (PERM)
(for CYCLE in (fetch CYCLES of PERM) collect (SETSIZE CYCLE])
(BINARY.LSTG
[LAMBDA (GROUP)
(for PERM in GROUP collect (for X in (CAR (fetch POWERS of PERM))
collect (LOG2 X])
(LST.BINARYG
[LAMBDA (GROUP)
(PROG (RESULTS CYCLES ORDERS P2 ORDER)
[for PERM in GROUP
do
(COND
((SETQ CYCLES (LISTCYCLES PERM))
(SETQ ORDER 1)
[for CYCLE in CYCLES do (SETQ ORDER (LCM ORDER (LENGTH CYCLE]
(SETQ ORDERS (CONS 1 (for I from 2 to (LLSH ORDER -1)
when (RELATIVELYPRIME I ORDER)
collect I)))
(SETQ P2 PERM)
(SETQ RESULTS
(CONS
[create
PERMUTATION ORDER ←(COND
((EQ ORDER 2)
NIL)
(T ORDERS))
CYCLES ←[SORT (for CYCLE in CYCLES collect
(LST.BINARY CYCLE))
(FUNCTION (LAMBDA (X Y)
(ILESSP (SETSIZE X)
(SETSIZE Y]
POWERS ←(CONS
(for X in PERM collect (LST.BINARY X))
(for I from 2 to (for I in ORDERS maximum I)
join (PROGN (SETQ P2 (PERMTIMES PERM P2))
(COND
((MEMB I ORDERS)
(LIST (for X in P2
collect (LST.BINARY
X]
RESULTS]
(RETURN RESULTS])
(BINARY.LST
[LAMBDA (L)
(COND
((NULL L)
NIL)
((NLISTP L)
(for X in (LISTELT L) collect (LOG2 X)))
(T (MAPCAR L (QUOTE BINARY.LST])
(LST.BINARY
[LAMBDA (L)
(COND
((NULL L)
NIL)
((NLISTP L)
(2TO L))
((NLISTP (CAR L))
(bind RSLT←0 for X in L do (SETQ RSLT (UNIONSET RSLT (LST.BINARY X)))
finally (RETURN RSLT)))
(T (MAPCAR L (QUOTE LST.BINARY])
(LOG2
[LAMBDA (X)
(PROG ((I 0))
LP [COND
((ZEROP X)
(RETURN I))
(T (SETQ X (LLSH X -1]
(SETQ I (ADD1 I))
(GO LP])
(CONTAINED
[LAMBDA (A B)
(ZEROP (LOGAND A (LOGXOR A B])
(LISTELT
[LAMBDA (NODES)
(PROG (FN RSLT)
LP [COND
((EMPTY NODES)
(RETURN (DREVERSE RSLT]
(SETQ RSLT (CONS (FIRST NODES)
RSLT))
(SETQ NODES (REST NODES))
(GO LP])
(DM
[NLAMBDA L
[COND
((LISTP (CAR L))
(ERROR (CAR L)
(QUOTE "NOT ATOM"]
[RPLACA (QUOTE CHANGEDPROPLST)
(CONS (CAR L)
(CAR (QUOTE CHANGEDPROPLST]
(AND LISPXHIST (UNDOSAVE (LIST (QUOTE /RPLACA)
CHANGEDPROPLST)))
(/PUT (CAR L)
(QUOTE MACRO)
(CDR L))
(ADDSPELL (CAR L))
(CAR L])
(SETDIFF
[LAMBDA (A B)
(LOGAND A (LOGXOR B A])
(SETSIZE
[LAMBDA (X)
(ADD1 (WHILE [NOT (EMPTY (SETQ X (REST X] SUM 1])
(FIRST
[LAMBDA (X)
(LOGAND X (LOGXOR X (SUB1 X])
(REST
[LAMBDA (X)
(LOGAND X (SUB1 X])
(LABELGRAPH
[LAMBDA (NODES NUMBER GROUP)
(* NODES: set to be labeled -
GROUP permutation group on NODES -
NUMBER number of labels to be attached -
returns list of all nonequivalent labelings of NODES with
<number> identical labels)
(COND
((NLISTP GROUP)
(for X in (ALLSUBSETS NODES NUMBER) collect (create LABELING LABELED ←
X)))
[(IGREATERP (TWICE NUMBER)
(SETSIZE NODES))
(for X in (LABELGRAPH NODES (IDIFFERENCE (SETSIZE NODES)
NUMBER)
GROUP)
rcollect (CREATE LABELING REUSING X LABELED ←(SETDIFF NODES @@]
((ZEROP NUMBER)
(LIST (CREATE LABELING LABELED ← 0 LSTRUC ← GROUP)))
(T (PROG (FC RESULT)
[COND
((EQSET NODES (SETQ FC (ORBIT1 NODES GROUP)))
(RETURN (LABELCLASS NODES NUMBER GROUP]
(SETQ NODES (SETDIFF NODES FC))
(RETURN (for X from (IMAX 0 (IDIFFERENCE NUMBER (SETSIZE NODES)))
to MAXI bind [(MAXI←(IMIN NUMBER (SETSIZE FC]
join (for LBL1 in (LABELCLASS FC X GROUP)
join (for LBL2 in (LABELGRAPH NODES
(CDR LBL1)
(IDIFFERENCE
NUMBER X))
rcollect (CREATE LABELING
REUSING
LBL2 LABELED ←(UNIONSET
(fetch LABELED
of LBL1)@@])
(INSERTCL
[LAMBDA (NUMBER ELEMENT OLDCL ORDERF)
(* NUMBER: the number of this type of element to insert -
ELEMENT: the element to insert -
OLDCL the composition list that NUMBER elements are to be
inserted into -
ORDERF a comparison function which returns NIL if the two
arguments are equal or if the first should come after the
second in the composition list -
Val OLDCL, with NUMBER elements added OLDCL is assumed to be
previously sorted by ORDERF)
(COND
((OR (NULL OLDCL)
(APPLY* ORDERF ELEMENT (CAAR OLDCL)))
(CONS (CONS ELEMENT NUMBER)
OLDCL))
((EQUAL (CAAR OLDCL)
ELEMENT)
(RPLACD (CAR OLDCL)
(IPLUS (CDAR OLDCL)
NUMBER))
OLDCL)
(T (RPLACD OLDCL (INSERTCL NUMBER ELEMENT (CDR OLDCL)
ORDERF])
(DIFFCL
[LAMBDA (L1 L2)
(* L1, L2 are two composition lists -
Val the (set) difference (L1-L2))
(for X in L1 bind N
when (IGREATERP (SETQ N (IDIFFERENCE (CDR X)
(OR (CDR (SASSOC (CAR X)
L2))
0)))
0)
collect (CONS (CAR X)
N])
(SUBSETS
[LAMBDA (C N)
(* C is a composition list of numbers.
-
N a number -
Value a list of dotted pairs ;the CAR of each is a
subcollection of C such that the elements of that
subcollection add up to N ;the CDR is the number of ways
that subcollection can be formed from the l's if the l's
were all different -
E,g, SUBSETS (((5 . 1) (4 . 2)
(1 . 1)) 5) yields (((5 . 1)) . 1)
(((4 . 1) (1 . 1)) . 2) since 5 can be obtained by taking
one 5 in one way ;or by taking a four and a one in two
different ways;)
(COND
[(EQ 0 N)
(QUOTE ((NIL . 1]
((on old C always (IGREATERP (CAAR C)
N))
NIL)
(T
(* get rid of numbers at head that are too big;
return NIL when they are all to big;
the first of the list is all subsets without using the first
of C)
(* the first element of the new subset is the first of the
old; try up to how many on the old;
I is the number of times it occurs and II is the amount
taken; IT is upper-bounded by N.
Try every subset of the reset adding up to N-II.)
(* X must not be NIL; the factor is the number of ways of
taking I elements out of the (CDAR C) element available)
(for I from 1 to (CDAR C) as II from (CAAR C) to N
by (CAAR C) bind X FACTOR
join (AND (SETQ X (SUBSETS (CDR C)
(IDIFFERENCE N II)))
(SETQ FACTOR (TAKEN (CDAR C)
I))
(NCONC [on old X
rcollect (CONS (CONS (CONS (CAAR C)
I)
(CAAR X))
(ITIMES FACTOR (CDAR X]
(SUBSETS (CDR C)
N])
(PCYCLEINDEX
[LAMBDA (CYCLES NODES)
(PROG (INDEX)
[for CYCLE in CYCLES do (SETQ INDEX (INSERTCL 1 (SETSIZE
(INTERSECT CYCLE
NODES))
INDEX
(QUOTE ILESSP]
(RETURN (COND
([NOT (EQP 0 (SETQ CYCLES
(IDIFFERENCE (SETSIZE NODES)
(for X in INDEX
sum (ITIMES (CAR X)
(CDR X]
(CONS (CONS 1 CYCLES)
INDEX))
(T INDEX])
(CYCLEINDEX
[LAMBDA (GROUP NODES)
(PROG (INDEX)
[for PERM in GROUP do (SETQ INDEX
(INSERTCL 1 (PCYCLEINDEX (fetch CYCLES
of PERM)
NODES)
INDEX
(FUNCTION (LAMBDA (X Y)
(AND (NOT (EQUAL X Y))
(ORDERED X Y]
(RETURN (CONS (CONS (LIST (CONS 1 (SETSIZE NODES)))
1)
INDEX])
(LFROMCL
[LAMBDA (CL N)
(SETQ CL (SORT (MAPCAR CL (QUOTE CDR))
(QUOTE ILESSP)))
(COND
([NOT (ZEROP (SETQ N (IDIFFERENCE N (sum X for X in CL]
(INSERT N CL (QUOTE ILESSP)))
(T CL])
(POLYA
[LAMBDA (NODES GROUP SUBLIST)
(* Args are the same as to MANYLABELGRAPH ;
however POLYA returns the number of labellings rather than
the actual labellings. Evaluates G.
POLYA's function for the number of double cosets of two
groups under SN -
METHOD: reset GROUP to a composition list of cycle indices;
th identity needs to be filled in;
the function PERMCYCLEINDEX1 given a PERMUTATION returns a
list of the sizes of the CYCLES of the perm, but CYCLES of
SIZE one are not included; note also that each PERMUTATION
in the original GROUP stands for 2*{LENGTH PERM:ORDER}
permutations unless ORDER is NIL, in which case it stands
for only one PERMUTATION. To compute the coeficient of
x1↑n1* x2↑n2*...Xk↑nk in the polynomial -
(sum for P in GROUP (product for C a cycle of P
(x1↑|c|+x2↑|c|...+xk↑|c|)) SUBLIST is
(n1 n2 ,,, nk) and NEWGROUP is the polynomial with
redundancies in the sum and product eliminated by using
composition lists))
(PROG [D C NEWGROUP (SUBLIST (LFROMCL SUBLIST (SETSIZE NODES]
(SETQ C (for PERM in (SETQ NEWGROUP (CYCLEINDEX GROUP NODES))
sum (CDR PERM)))
L1 [COND
((NULL (CDR SUBLIST))
(RETURN (IQUOTIENT (for X in NEWGROUP sum (CDR X))
C]
(SETQ GROUP NEWGROUP)
(SETQ NEWGROUP NIL)
[for X in GROUP
do (for S in (SUBSETS (CAR X)
(CAR SUBLIST))
do (SETQ NEWGROUP (INSERTCL (ITIMES (CDR X)
(CDR S))
(DIFFCL (CAR X)
(CAR S))
NEWGROUP
(FUNCTION (LAMBDA (X Y)
(AND (NOT (EQUAL X Y))
(ORDERED X Y]
(SETQ SUBLIST (CDR SUBLIST))
(GO L1])
(INSERT
[LAMBDA (ITEM LST CMPR)
(COND
((OR (NULL LST)
(APPLY* CMPR ITEM (CAR LST)))
(CONS ITEM LST))
(T (FRPLACD LST (INSERT ITEM (CDR LST)
CMPR])
(SLTPSANDPINVS
[LAMBDA (S P)
(* S is a set of nodes; P is a permutation in the same same
notation as in SLTPS. Checks if S is lexicographically less
than P{S} at the same time it checks P↑-1 %.
-
METHOD: as in SLTPS, I starts at the largest element
possible and goes down until S and P{S} disagree.
Meanwhile, P↑-1{S} is accumulated in R;
The complement of P↑-1{S} is accumulated in NR;
a running check is made on the frst location where S and R
disagree if that element is contained in R, then it is known
that P↑-1{S} >> S; then it is only necessary to check S<<PS
from then on; otherwise, if XI is the largest element for
which S and R disagree, and XI is in S, then if all larger
elements not in S are in NR, then we know that S>>P↑-1{S}
and can return)
(PROG (I R NR XI LARGERTHANXI)
(SETQ R (SETQ NR 0))
[SETQ LARGERTHANXI (ALLLARGERELTS (SETQ XI (FIRST S]
(SETQ I (LARGESTELT))
LOOP(COND
[(CONTAINED I S)
(COND
[(CONTAINED (CAR P)
S)
(* S and PS agree, check P↑-1 S.
I is in S so we can add (CAR P) to R)
(SETQ R (UNIONSET (CAR P)
S))
(COND
((CONTAINED (SETQ XI (FIRST (DISJOINTDIFF S R)))
R)
(RETURN (SLTPS I S P)))
((AND (CONTAINED (SETQ LARGERTHANXI (SETDIFF (ALLLARGERELTS
XI)
S))
NR)
(CONTAINED XI NR))
(RETURN]
(T (RETURN]
((CONTAINED (CAR P)
S)
(GO INVERSEONLY))
((AND (CONTAINED XI (SETQ NR (UNIONSET (CAR P)
NR)))
(CONTAINED LARGERTHANXI NR))
(RETURN)))
[COND
([OR (ELTLESSP (SETQ I (NEXTSMALLESTELT I))
S)
(NULL (SETQ P (CDR P]
(RETURN (QUOTE EQL]
(GO LOOP)
INVERSEONLY
(SETQ NR (UNIONSET I NR))
LOOP2
(COND
((AND (CONTAINED XI NR)
(CONTAINED LARGERTHANXI NR))
(RETURN)))
[COND
((EQ NIL (SETQ P (CDR P)))
(RETURN (QUOTE EQL]
(SETQ I (NEXTSMALLESTELT I))
[COND
((CONTAINED I S)
(SETQ R (UNION I R))
(COND
((CONTAINED (SETQ X1 (FIRST (DISJOINTDIFF S R)))
R)
(RETURN T)))
(SETQ LARGERTHANXI (SETDIFF (ALLLARGERELTS XI)
S]
(GO LOOP2])
)
(DEFINEQ
(MLG
[LAMBDA (NODES GROUP LABELS)
(FOR X IN (MANYLABELGRAPHTOP (LST.BINARY NODES)
(LST.BINARYG GROUP)
LABELS)
DO (for Y in (CDR X) do (PRIN1 (CAR Y))
(PRIN1 (BINARY.LST (CDR Y)))
(SPACES 2))
[COND
((LISTP (CAR (QUOTE PICTURE)))
(for I from 1 to MAXI bind [(MAXI←(for II in PICTURE
maximum (CADR II]
do (TERPRI)
(for P in PICTURE when (EQ I (CADR P)) bind ELT Y
do (SETQ ELT (LST.BINARY (CAR P)))
(SETQ Y X)
(PROG NIL
(COND
((NOT (NUMBERP (CAR P)))
(GO L2)))
(TAB (CDDR P))
L1 [COND
((NULL (SETQ Y (CDR Y)))
(PRIN1 (QUOTE ?)))
((DISJOINT ELT (CDAR Y))
(GO L1))
(T (PRIN1 (CAAR Y]
(GO L3)
L2 (PRIN1 (CAR P))
L3]
(TERPRI)
(PRIN1 (QUOTE "REMAINING GROUP ="))
(TAB 2)
(PRINT (BINARY.LSTG (CAR X])
(ORBIT1
[LAMBDA (NODES GROUP)
(* NODES is a set -
GROUP is a GROUP of permutations on NODES -
returns the subset of NODES which is the orbit of
(FIRST NODES) under the permutations of GROUP)
(PROG (CLASS)
(SETQ CLASS (FIRST NODES))
[on old GROUP do (for PERM on (fetch CYCLES of (CAR GROUP))
bind CYCLE when (NOT (DISJOINT (SETQ CYCLE
(CAR PERM))
CLASS))
do (SETQ CLASS (UNIONSET CYCLE CLASS]
(RETURN (INTERSECT CLASS NODES])
(REDUCEGROUP
[LAMBDA (GROUP NODES)
(* returns the subgroup of GROUP which stableizes NODES as a
set i.e. P s.t. P{NODES}=NODES)
(ON OLD GROUP WHEN (for PERM on (fetch CYCLES of (CAR GROUP)) bind CYCLE X
always (OR [EMPTY (SETQ X (INTERSECT NODES
(SETQ CYCLE
(CAR PERM]
(EQSET X CYCLE)))
COLLECT (CAR GROUP])
(ALLSUBSETS
[LAMBDA (NODES NUMBER)
(COND
((EQ 0 NUMBER)
(LIST 0))
((EMPTY NODES)
NIL)
((EQ NUMBER 1)
(LISTELT NODES))
(T (for NN from (SETSIZE NODES) to NUMBER by -1
join (for X in (ALLSUBSETS (PROGN (SETQ FN (FIRST NODES))
(SETQ NODES (REST NODES)))
(SUB1 NUMBER))
rcollect (UNIONSET FN X])
(MANYLABELGRAPHTOP
[LAMBDA (NODES GROUP LABELS)
(* This is a special top level function which calls first
POLYA and then MANYLABELGRAPH if the result of the POLYA
function show that there are too many structures to
calculate in a reasonable length of time, MANYLABELGRAPH is
not called)
(PROG (X SZNODES)
(SETQ SZNODES (SETSIZE NODES))
[SORT LABELS (FUNCTION (LAMBDA (X Y)
(ILESSP (CDR X)
(CDR Y]
(SETQ X (POLYA NODES GROUP LABELS))
[PRINT (CONS X (QUOTE (POSSIBLE SUBSTITUTION (S]
[COND
((IGREATERP X 1000)
(RETURN (PROGN (PRINT (QUOTE (THIS IS TOO MANY TO COMPUTE)))
NIL]
(SETQ X (MANYLABELGRAPH NODES GROUP LABELS))
[PRINT (CONS (LENGTH X)
(QUOTE (ACTUAL SUBSTITUTIONS MADE]
(RETURN X])
(MANYLABELGRAPH
[LAMBDA (NODES LABELS GROUP)
(* NODES: set to be LABELED -
GROUP: permutation group on NODES -
LABELS a list of dotted pairs of label,number -
VAL: list of all nonequivalent labelings of NODES)
(COND
((NULL LABELS)
(LIST (create LABELING LABELED ← NIL)))
[(NULL (CDR LABELS))
(for X in (LABELGRAPH NODES (CAR LABELS)
GROUP)
rcollect (create LABELING reusing X LABELED ←(LIST @@]
(T (for L1 in (LABELGRAPH NODES (CAR LABELS)
GROUP)
join (for L2 in (MANYLABELGRAPH (SETDIFF NODES
(fetch LABELED
of L1))
(CDR LABELS)
(fetch LSTRUC of L1))
rcollect (create LABELING
reusing L2 LABELED ←(CONS (fetch LABELED
of L1)@@])
(LABELCLASS
[LAMBDA (CLASS NUMBER GROUP)
(* CLASS a set -
GROUP permutation GROUP on CLASS, such that all the elements
of CLASS are equivalent under GROUP -
NUMBER number of labels to attach to CLASS -
VAL a list of labelings, as in LABELGRAPH)
(COND
[(IGREATERP (TWICE NUMBER)
(SETSIZE CLASS))
(for X in (LABELCLASS CLASS (IDIFFERENCE (SETSIZE CLASS)
NUMBER)
GROUP)
rcollect (CREATE LABELING REUSING X LABELED←(SETDIFF CLASS @@]
((ZEROP NUMBER)
(CREATE LABELING LABELED← 0 LSTRUC←GROUP))
[(EQ NUMBER 1)
(LIST (CREATE LABELING LABELED ←(SETQ CLASS (FIRST CLASS))
LSTRUC ←(REDUCEGROUP GROUP CLASS]
(T (LABELGENCLASS CLASS NUMBER GROUP])
(LABELGENCLASS
[LAMBDA (CLASS NUMBER GROUP)
(* Calls LABELORBITS and then reduces the list by checking
CANONICAL. Note that one could alternativly: -
make LABELORBITS CHECK as it generates -
the checking procedure could generate a badlist, and the
badlist would be all that needed to be checked)
(* Making use of SIMS, compute candidate labellings and
check if they are CANONICAL)
(for X in (LABELORBITS (ORBITS CLASS GROUP)
NUMBER)
when (CANONICAL X GROUP) collect (create LABELING LABELED ← X LSTRUC ←(
REDUCEGROUP GROUP X])
(LABELORBITS
[LAMBDA (ORBITS NUMBER)
(* To make the LABELORBITS function independent of whether
or not the labelings are checked as they are generated, or
if they are all generated and then checked, LABELORBITS
calls a function LOADD with each new labelling;
LOADD can then either add that labelling to a list, or CHECK
it first)
(* ORBITS is a list of sets determined from the permutation
group of the nodes to be labelled: the i-th set is the orbit
of the i-th node under those permutations that leave node 1
through node (i-1) fixed -
NUMBER is the number of labels to attach -
returns a list of subsets of NODES with NUMBER elements,
each of which satisfy the relation: -
if the i-th node is not in S, then no element of the i-th
orbit is in S I.e. the orbits of the stabelizer subgroups)
(PROG (LORESULT)
(LO1 ORBITS NUMBER 0)
(RETURN LORESULT])
(LO1
[LAMBDA (ORBITS NUMBER SET)
(COND
((MINUSP NUMBER)
NIL)
((ZEROP NUMBER)
(LOADD SET))
((ILESSP (LENGTH ORBITS)
NUMBER)
NIL)
[(EQLENGTH ORBITS NUMBER) (* exactly NUMBER orbits left;
collect the first of each orbit)
(LOADD (PROG ((RESULT SET))
[for X in ORBITS do (SETQ RESULT (UNIONSET RESULT
(FIRST X]
(RETURN RESULT]
(T (* try labelling NUMBER orbits
without labelling this one)
(LO1 (CDR ORBITS)
NUMBER SET)
(* If you label (FIRST (CAR ORBITS)) then you must label all
of (CAR ORBITS) -
Since s<<ps => p (x) << p (Ox); here Ox is
(CAR ORBITS), x is (FIRST OX) and if any of Ox is on, then x
must be)
(LO1 (for O in (CDR ORBITS) when (DISJOINT (FIRST O)
(CAR ORBITS))
collect O)
(IDIFFERENCE NUMBER (SETSIZE (CAR ORBITS)))
(UNIONSET SET (CAR ORBITS])
(LOADD
[LAMBDA (NODES)
(SETQ LORESULT (CONS NODES LORESULT])
(ORBITS
[LAMBDA (NODES GROUP)
(* NODES is a set; GROUP is a permutation group on set -
returns the list of orbits of the i-th node under those
permutations leaving nodes 1 to i-1 fixed;
i.e. the stabilizer subgroups of SIMS)
(COND
((EMPTY NODES)
NIL)
((NULL GROUP)
(LISTELT NODES))
(T (CONS (ORBIT1 NODES GROUP)
(ORBITS (REST NODES)
(REDUCEGROUP GROUP (FIRST NODES])
(CANONICAL
[LAMBDA (NODES GROUP)
(EVERY GROUP (FUNCTION (LAMBDA (PERM)
(COND
[(NULL (fetch ORDER of PERM))
(SLTPS (LARGESTELT)
NODES
(CAR (fetch POWERS of PERM]
(T (for P in (fetch POWERS of PERM) bind PRED
while (NEQ (SETQ PRED (SLTPSANDPINVS NODES P))
(QUOTE EQL))
always PRED])
(SLTPS
[LAMBDA (I S P)
(* S is a set of nodes; P is a permutation represented as
the list (P↑-1{X1},P↑-1{X2}...) -
returns NIL if S is lexicographically less than P{S} and T
otherwise. To determine lexicographic order: order the
elements of S in the order X1, X2, ,,, XN.
Order the elements of P{S} in the same way.
Then S << P{S} if at the first element where they differ,
the element of S is an earlier element than the
corresponding element of P{S} -
METHOD: as I goes from X1 to XN
(LARGESTELT) by NEXTSMALLESTELT, P↑-1{I} in S iff I in P{S}
Procede until it is no longer true that I in S => I in P{S}
(I.e. P INVERSE{I}≠I at that point.
If I is in S, then S>>P{S}; if I is in P{S} then S<<P{S}))
(PROG NIL
L1 [COND
[(NOT (CONTAINED I S))
(COND
((CONTAINED (CAR P)
S)
(RETURN T))
(T (SETQ P (CDR P))
(SETQ I (NEXTSMALLESTELT I]
((NOT (CONTAINED (CAR P)
S))
(RETURN NIL))
((ELTLESSP (SETQ I (NEXTSMALLESTELT I))
S)
(RETURN (QUOTE EQL)))
(T (SETQ P (CDR P]
(GO L1])
)
(RPAQQ INPUTMODE FUNCTION)
STOP